home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / src / pl-arith.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-04-15  |  29.3 KB  |  1,373 lines
  1. /*  $Id: pl-arith.c,v 1.36 1998/04/15 15:16:52 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: arithmetic built in functions
  8. */
  9.  
  10. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  11. The arithmetic module defines a small set of logical integer  predicates
  12. as   well   as  the  evaluation  of  arbitrary  arithmetic  expressions.
  13. Arithmetic can be interpreted or compiled (see  -O  flag).   Interpreted
  14. arithmetic  is  supported  by  the  built-in  predicates is/2, >/2, etc.
  15. These functions call valueExpression() to evaluate a Prolog term holding
  16. an arithmetic expression.
  17.  
  18. For compiled arithmetic, the compiler generates WAM codes that execute a
  19. stack machine.  This module maintains an array of arithmetic  functions.
  20. These  functions are addressed by the WAM instructions using their index
  21. in this array.
  22.  
  23. The  current  version  of  this  module  also  supports  Prolog  defined
  24. arithmetic  functions.   In  the  current  version these can only return
  25. numbers.  This should be changed to return arbitrary Prolog  terms  some
  26. day.
  27. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  28.  
  29. #include <math.h>            /* avoid abs() problem with MSVC++ */
  30. #include "pl-incl.h"
  31. #ifndef M_PI
  32. #define M_PI (3.14159265358979323846)
  33. #endif
  34. #ifndef M_E
  35. #define M_E (2.7182818284590452354)
  36. #endif
  37.  
  38. #if !defined(HAVE_ISNAN) && defined(NaN)
  39. #define isnan(f)  ((f) == NaN)
  40. #define HAVE_ISNAN
  41. #endif
  42.  
  43. #ifdef HAVE___TRY
  44. #include <excpt.h>
  45. #endif
  46.  
  47. typedef int (*ArithF)();
  48.  
  49. struct arithFunction
  50. { ArithFunction next;        /* Next of chain */
  51.   functor_t    functor;    /* Functor defined */
  52.   ArithF    function;    /* Implementing function */
  53.   Module    module;        /* Module visibility module */
  54. #if O_PROLOG_FUNCTIONS
  55.   Procedure    proc;        /* Prolog defined functions */
  56. #endif
  57. #if O_COMPILE_ARITH
  58.   code        index;        /* Index of function */
  59. #endif
  60. };
  61.  
  62. #define arithFunctionTable    (GD->arith.table)
  63. #define function_array        (&GD->arith.functions)
  64. #define FunctionFromIndex(n)    fetchBuffer(function_array, n, ArithFunction)
  65.  
  66. static ArithFunction    isCurrentArithFunction(functor_t, Module);
  67. static void        registerFunction(ArithFunction f);
  68. static void        promoteToRealNumber(Number n);
  69.  
  70.  
  71.         /********************************
  72.         *   LOGICAL INTEGER FUNCTIONS   *
  73.         *********************************/
  74.  
  75. word
  76. pl_between(term_t low, term_t high, term_t n, word b)
  77. { switch( ForeignControl(b) )
  78.   { case FRG_FIRST_CALL:
  79.       { long l, h, i;
  80.  
  81.     if ( !PL_get_long(low, &l) )
  82.       return PL_error("between", 3, NULL, ERR_TYPE, ATOM_integer, low);
  83.     if ( !PL_get_long(high, &h) )
  84.       return PL_error("between", 3, NULL, ERR_TYPE, ATOM_integer, high);
  85.  
  86.     if ( PL_get_long(n, &i) )
  87.     { if ( i >= l && i <= h )
  88.         succeed;
  89.       fail;
  90.     }
  91.     if ( !PL_is_variable(n) )
  92.       return PL_error("between", 3, NULL, ERR_TYPE, ATOM_integer, n);
  93.     if ( h < l )
  94.       fail;
  95.  
  96.     PL_unify_integer(n, l);
  97.     if ( l == h )
  98.       succeed;
  99.     ForeignRedoInt(l);
  100.       }
  101.     case FRG_REDO:
  102.       { long next = ForeignContextInt(b) + 1;
  103.     long h;
  104.  
  105.     PL_unify_integer(n, next);
  106.     PL_get_long(high, &h);
  107.     if ( next == h )
  108.       succeed;
  109.     ForeignRedoInt(next);
  110.       }
  111.     default:;
  112.       succeed;
  113.   }
  114. }
  115.  
  116. word
  117. pl_succ(term_t n1, term_t n2)
  118. { long i1, i2;
  119.  
  120.   if ( PL_get_long(n1, &i1) )
  121.   { if ( PL_get_long(n2, &i2) )
  122.       return i1+1 == i2 ? TRUE : FALSE;
  123.     else if ( PL_unify_integer(n2, i1+1) )
  124.       succeed;
  125.  
  126.     return PL_error("succ", 2, NULL, ERR_TYPE, ATOM_integer, n2);
  127.   }
  128.   if ( PL_get_long(n2, &i2) )
  129.   { if ( PL_unify_integer(n1, i2-1) )
  130.       succeed;
  131.   }
  132.  
  133.   return PL_error("succ", 2, NULL, ERR_TYPE, ATOM_integer, n1);
  134. }
  135.  
  136.  
  137. static int
  138. var_or_long(term_t t, long *l, int which, int *mask)
  139. { if ( PL_get_long(t, l) )
  140.   { *mask |= which;
  141.     succeed;
  142.   } 
  143.   if ( PL_is_variable(t) )
  144.     succeed;
  145.     
  146.   return PL_error("plus", 3, NULL, ERR_TYPE, ATOM_integer, t);
  147. }
  148.  
  149.  
  150. word
  151. pl_plus(term_t a, term_t b, term_t c)
  152. { long m, n, o;
  153.   int mask = 0;
  154.  
  155.   if ( !var_or_long(a, &m, 0x1, &mask) ||
  156.        !var_or_long(b, &n, 0x2, &mask) ||
  157.        !var_or_long(c, &o, 0x4, &mask) )
  158.     fail;
  159.  
  160.   switch(mask)
  161.   { case 0x7:
  162.       return m+n == o ? TRUE : FALSE;
  163.     case 0x3:                /* +, +, - */
  164.       return PL_unify_integer(c, m+n);
  165.     case 0x5:                /* +, -, + */
  166.       return PL_unify_integer(b, o-m);
  167.     case 0x6:                /* -, +, + */
  168.       return PL_unify_integer(a, o-n);
  169.     default:
  170.       return PL_error("succ", 2, NULL, ERR_INSTANTIATION);
  171.   }
  172. }
  173.  
  174.  
  175.         /********************************
  176.         *           COMPARISON          *
  177.         *********************************/
  178.  
  179. int
  180. ar_compare(Number n1, Number n2, int what)
  181. { int result;
  182.  
  183.   if ( intNumber(n1) && intNumber(n2) )
  184.   { switch(what)
  185.     { case LT:    result = n1->value.i <  n2->value.i; break;
  186.       case GT:  result = n1->value.i >  n2->value.i; break;
  187.       case LE:    result = n1->value.i <= n2->value.i; break;
  188.       case GE:    result = n1->value.i >= n2->value.i; break;
  189.       case NE:    result = n1->value.i != n2->value.i; break;
  190.       case EQ:    result = n1->value.i == n2->value.i; break;
  191.       default:    fail;
  192.     }
  193.     if ( result )
  194.       succeed;
  195.   } else
  196.   { promoteToRealNumber(n1);
  197.     promoteToRealNumber(n2);
  198.  
  199.     switch(what)
  200.     { case LT:    result = n1->value.f <  n2->value.f; break;
  201.       case GT:  result = n1->value.f >  n2->value.f; break;
  202.       case LE:    result = n1->value.f <= n2->value.f; break;
  203.       case GE:    result = n1->value.f >= n2->value.f; break;
  204.       case NE:    result = n1->value.f != n2->value.f; break;
  205.       case EQ:    result = n1->value.f == n2->value.f; break;
  206.       default:    fail;
  207.     }
  208.     if ( result )
  209.       succeed;
  210.   }  
  211.  
  212.   fail;
  213. }
  214.  
  215.  
  216. static word
  217. compareNumbers(term_t n1, term_t n2, int what)
  218. { number left, right;
  219.  
  220.   TRY(valueExpression(n1, &left) &&
  221.       valueExpression(n2, &right));
  222.  
  223.   return ar_compare(&left, &right, what);
  224. }
  225.  
  226.  
  227. word
  228. pl_lessNumbers(term_t n1, term_t n2)            /* </2 */
  229. { return compareNumbers(n1, n2, LT);
  230. }
  231.  
  232. word
  233. pl_greaterNumbers(term_t n1, term_t n2)            /* >/2 */
  234. { return compareNumbers(n1, n2, GT);
  235. }
  236.  
  237. word
  238. pl_lessEqualNumbers(term_t n1, term_t n2)        /* =</2 */
  239. { return compareNumbers(n1, n2, LE);
  240. }
  241.  
  242. word
  243. pl_greaterEqualNumbers(term_t n1, term_t n2)        /* >=/2 */
  244. { return compareNumbers(n1, n2, GE);
  245. }
  246.  
  247. word
  248. pl_nonEqualNumbers(term_t n1, term_t n2)        /* =\=/2 */
  249. { return compareNumbers(n1, n2, NE);
  250. }
  251.  
  252. word
  253. pl_equalNumbers(term_t n1, term_t n2)            /* =:=/2 */
  254. { return compareNumbers(n1, n2, EQ);
  255. }
  256.  
  257.         /********************************
  258.         *           FUNCTIONS           *
  259.         *********************************/
  260.  
  261. static ArithFunction
  262. isCurrentArithFunction(functor_t f, Module m)
  263. { ArithFunction a;
  264.   ArithFunction r = NULL;
  265.   int level = 30000;
  266.  
  267.   for(a = arithFunctionTable[functorHashValue(f, ARITHHASHSIZE)];
  268.       a && !isTableRef(a); a = a->next)
  269.   { if ( a->functor == f )
  270.     { Module m2;
  271.       int l;
  272.  
  273.       for( m2 = m, l = 0; m2; m2 = m2->super, l++ )
  274.       { if ( m2 == a->module && l < level )
  275.     { r = a;
  276.       level = l;
  277.     }
  278.       }
  279.     }
  280.   }
  281.  
  282.   return r;
  283. }
  284.  
  285. #if HAVE_SIGNAL
  286. typedef void (*OsSigHandler)(int);
  287.  
  288. static void
  289. realExceptionHandler(int sig, int type, SignalContext scp, char *addr)
  290. {
  291. #ifndef BSD_SIGNALS
  292.   signal(sig, (OsSigHandler)realExceptionHandler);
  293. #endif
  294.   if ( LD->in_arithmetic > 0 )
  295.   { warning("Floating point exception");
  296. #ifndef O_RUNTIME
  297.     Sfprintf(Serror, "[PROLOG STACK:\n");
  298.     backTrace(NULL, 10);
  299.     Sfprintf(Serror, "]\n");
  300. #endif
  301.     pl_abort();
  302.   } else
  303.   { deliverSignal(sig, type, scp, addr);
  304.   }
  305. }
  306. #endif
  307.  
  308. #if __TURBOC__
  309. static int
  310. realExceptionHandler(e)
  311. struct exception *e;
  312. { warning("Floating point exception");
  313.  
  314.   pl_abort();
  315.   /*NOTREACHED*/
  316.   fail;                /* make tc happy */
  317. }
  318. #endif
  319.  
  320.  
  321. #if O_PROLOG_FUNCTIONS
  322.  
  323. static int prologFunction(ArithFunction, term_t, Number);
  324.  
  325. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  326. Activating a Prolog predicate as function below the arithmetic functions
  327. is/0, >, etc. `f' is the arithmetic function   to  be called. `t' is the
  328. base term-reference of an array holding  the proper number of arguments.
  329. `r' is the result of the evaluation.
  330.  
  331. This calling convention is somewhat  unnatural,   but  fits  best in the
  332. calling convention required by ar_func_n() below.
  333. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  334.  
  335. static int
  336. prologFunction(ArithFunction f, term_t av, Number r)
  337. { int arity = f->proc->definition->functor->arity;
  338.   fid_t fid = PL_open_foreign_frame();
  339.   qid_t qid;
  340.   int rval;
  341.  
  342.   qid = PL_open_query(NULL, PL_Q_CATCH_EXCEPTION, f->proc, av);
  343.  
  344.   if ( PL_next_solution(qid) )
  345.   { rval = valueExpression(av+arity-1, r);
  346.     PL_close_query(qid);
  347.     PL_discard_foreign_frame(fid);
  348.   } else
  349.   { term_t except;
  350.  
  351.     if ( (except = PL_exception(qid)) )
  352.     { rval = PL_throw(except);        /* pass exception */
  353.     } else
  354.     { char *name = stringAtom(f->proc->definition->functor->name);
  355.  
  356.       rval = PL_error(name, arity-1, NULL, ERR_FAILED, f->proc);
  357.     }
  358.  
  359.     PL_cut_query(qid);            /* donot destroy data */
  360.     PL_close_foreign_frame(fid);    /* same */
  361.   }
  362.  
  363.   return rval;
  364. }
  365.  
  366. #endif /* O_PROLOG_FUNCTIONS */
  367.  
  368. int
  369. valueExpression(term_t t, Number r)
  370. { ArithFunction f;
  371.   functor_t functor;
  372.   Word p = valTermRef(t);
  373.   word w;
  374.  
  375.   deRef(p);
  376.   w = *p;
  377.  
  378.   switch(tag(w))
  379.   { case TAG_INTEGER:
  380.       r->value.i = valInteger(w);
  381.       r->type = V_INTEGER;
  382.       succeed;
  383.     case TAG_FLOAT:
  384.       r->value.f = valReal(w);
  385.       r->type = V_REAL;
  386.       succeed;
  387.     case TAG_VAR:
  388.       return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
  389.     case TAG_ATOM:
  390.       functor = lookupFunctorDef(w, 0);
  391.       break;
  392.     case TAG_COMPOUND:
  393.       functor = functorTerm(w);
  394.       break;
  395.     default:
  396.       return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_number, t);
  397.   }
  398.  
  399.   if ( !(f = isCurrentArithFunction(functor,
  400.                     contextModule(environment_frame))))
  401.   { if ( functor == FUNCTOR_dot2 )    /* handle "a" (make function) */
  402.     { Word a, b, p = valTermRef(t);
  403.  
  404.       deRef(p);
  405.       a = argTermP(*p, 0);
  406.       deRef(a);
  407.       if ( isTaggedInt(*a) )
  408.       { b = argTermP(*p, 1);
  409.     deRef(b);
  410.     if ( *b == ATOM_nil )
  411.     { r->value.i = valInt(*a);
  412.       r->type = V_INTEGER;
  413.       succeed;
  414.     } else
  415.     { term_t a2 = PL_new_term_ref();
  416.       PL_get_arg(2, t, a2);
  417.       return PL_error(".", 2, NULL, ERR_TYPE, ATOM_nil, a2);
  418.     }
  419.       } else
  420.       { term_t a1 = PL_new_term_ref();
  421.     PL_get_arg(1, t, a1);
  422.     return PL_error(".", 2, NULL, ERR_TYPE, ATOM_integer, a1);
  423.       }
  424.     } else
  425.       return PL_error(NULL, 0, NULL, ERR_NOT_EVALUABLE, functor);
  426.   }
  427.  
  428. #if O_PROLOG_FUNCTIONS
  429.   if ( f->proc )
  430.   { int rval, n, arity = arityFunctor(functor);
  431.     term_t h0 = PL_new_term_refs(arity+1); /* one extra for the result */
  432.  
  433.     for(n=0; n<arity; n++)
  434.     { number n1;
  435.  
  436.       PL_get_arg(n+1, t, h0+n);
  437.       if ( valueExpression(h0+n, &n1) )
  438.       { _PL_put_number(h0+n, &n1);
  439.       } else
  440.     fail;
  441.     }
  442.  
  443.     rval = prologFunction(f, h0, r);
  444.     PL_reset_term_refs(h0);
  445.     return rval;
  446.   }
  447. #endif
  448.  
  449.   DEBUG(3, Sdprintf("Starting __try ...\n"));
  450.  
  451.   { int rval;
  452.  
  453. #ifdef HAVE___TRY
  454. #ifndef EXCEPTION_EXECUTE_HANDLER    /* lcc */
  455. #define EXCEPTION_EXECUTE_HANDLER 1
  456. #endif
  457.     __try
  458.     {
  459. #else
  460.     LD->in_arithmetic++;
  461. #endif
  462.     switch(arityFunctor(functor))
  463.     { case 0:
  464.     rval = (*f->function)(r);
  465.         break;
  466.       case 1:    
  467.       { term_t a = PL_new_term_ref();
  468.     number n1;
  469.  
  470.     PL_get_arg(1, t, a);
  471.     if ( valueExpression(a, &n1) )
  472.       rval = (*f->function)(&n1, r);
  473.     else
  474.       rval = FALSE;
  475.  
  476.     PL_reset_term_refs(a);
  477.     break;
  478.       }
  479.       case 2:
  480.       { term_t a = PL_new_term_ref();
  481.     number n1, n2;
  482.  
  483.     PL_get_arg(1, t, a);
  484.     if ( valueExpression(a, &n1) )
  485.     { PL_get_arg(2, t, a);
  486.       if ( valueExpression(a, &n2) )
  487.         rval = (*f->function)(&n1, &n2, r);
  488.       else
  489.         rval = FALSE;
  490.     } else
  491.       rval = FALSE;
  492.  
  493.     PL_reset_term_refs(a);
  494.     break;
  495.       }
  496.       default:
  497.     sysError("Illegal arity for arithmic function");
  498.         rval = FALSE;
  499.     }
  500. #if defined(HAVE___TRY)
  501.     } __except(EXCEPTION_EXECUTE_HANDLER)
  502.     { warning("Floating point exception");
  503. #ifndef O_RUNTIME
  504.       Sfprintf(Serror, "[PROLOG STACK:\n");
  505.       backTrace(NULL, 10);
  506.       Sfprintf(Serror, "]\n");
  507. #endif
  508.       pl_abort();
  509.     }
  510. #else /*HAVE___TRY*/
  511.     LD->in_arithmetic--;
  512. #endif /*HAVE___TRY*/
  513.  
  514.     if ( r->type == V_REAL )
  515.     {
  516. #ifdef HUGE_VAL
  517.       if ( r->value.f == HUGE_VAL )
  518.     return PL_error(NULL, 0, NULL, ERR_AR_OVERFLOW);
  519. #endif
  520. #ifdef HAVE_ISNAN
  521.       if ( isnan(r->value.f) )
  522.     return PL_error(NULL, 0, NULL, ERR_AR_UNDEF);
  523. #endif
  524.     }
  525.  
  526.     return rval;
  527.   }
  528. }
  529.  
  530.          /*******************************
  531.          *         CONVERSION        *
  532.          *******************************/
  533.  
  534. static void
  535. promoteToRealNumber(Number n)
  536. { if ( intNumber(n) )
  537.   { n->value.f = (real)n->value.i;
  538.     n->type = V_REAL;
  539.   }
  540. }
  541.  
  542.  
  543. int
  544. toIntegerNumber(Number n)
  545. { if ( floatNumber(n) )
  546.   { long l;
  547.  
  548. #ifdef DOUBLE_TO_LONG_CAST_RAISES_SIGFPE
  549.     if ( !((n->value.f >= PLMININT) && (n->value.f <= PLMAXINT)) )
  550.       fail;
  551. #endif
  552.  
  553.     l = (long)n->value.f;
  554.     if ( n->value.f == (real) l )
  555.     { n->value.i = l;
  556.       n->type = V_INTEGER;
  557.       succeed;
  558.     }
  559.  
  560.     fail;
  561.   }
  562.  
  563.   succeed;
  564. } 
  565.  
  566.  
  567. void
  568. canoniseNumber(Number n)
  569. { if ( n->type == V_REAL )        /* only if not explicit! */
  570.   { long l;
  571.  
  572. #ifdef DOUBLE_TO_LONG_CAST_RAISES_SIGFPE
  573.     if ( !((n->value.f >= PLMININT) && (n->value.f <= PLMAXINT)) )
  574.       return;
  575. #endif
  576.  
  577.     l = (long)n->value.f;
  578.     if ( n->value.f == (real) l )
  579.     { n->value.i = l;
  580.       n->type = V_INTEGER;
  581.     }
  582.   }
  583. }
  584.  
  585.  
  586.         /********************************
  587.         *     ARITHMETIC FUNCTIONS      *
  588.         *********************************/
  589.  
  590. static int
  591. ar_add(Number n1, Number n2, Number r)
  592. { if ( intNumber(n1) && intNumber(n2) ) 
  593.   { r->value.i = n1->value.i + n2->value.i; 
  594.     
  595.     if ( n1->value.i > 0 && n2->value.i > 0 && r->value.i <= 0 )
  596.       goto overflow;
  597.     if ( n1->value.i < 0 && n2->value.i < 0 && r->value.i >= 0 )
  598.       goto overflow;
  599.  
  600.     r->type = V_INTEGER;
  601.     succeed;
  602.   } 
  603.  
  604. overflow:
  605.   promoteToRealNumber(n1);
  606.   promoteToRealNumber(n2);
  607.   r->value.f = n1->value.f + n2->value.f; 
  608.   r->type = V_REAL;
  609.  
  610.   succeed;
  611. }
  612.  
  613.  
  614. static int
  615. ar_minus(Number n1, Number n2, Number r)
  616. { if ( intNumber(n1) && intNumber(n2) ) 
  617.   { r->value.i = n1->value.i - n2->value.i; 
  618.     
  619.     if ( n1->value.i > 0 && n2->value.i < 0 && r->value.i <= 0 )
  620.       goto overflow;
  621.     if ( n1->value.i < 0 && n2->value.i > 0 && r->value.i >= 0 )
  622.       goto overflow;
  623.  
  624.     r->type = V_INTEGER;
  625.     succeed;
  626.   } 
  627.  
  628. overflow:
  629.   promoteToRealNumber(n1);
  630.   promoteToRealNumber(n2);
  631.   r->value.f = n1->value.f - n2->value.f; 
  632.   r->type = V_REAL;
  633.  
  634.   succeed;
  635. }
  636.  
  637.  
  638. /* Unary functions requiring double argument */
  639.  
  640. #define UNAIRY_FLOAT_FUNCTION(name, op) \
  641.   static int \
  642.   name(Number n1, Number r) \
  643.   { promoteToRealNumber(n1); \
  644.     r->value.f = op(n1->value.f); \
  645.     r->type    = V_REAL; \
  646.     succeed; \
  647.   }
  648.  
  649. /* Binary functions requiring integer argument */
  650.  
  651. #define BINAIRY_INT_FUNCTION(name, plop, op) \
  652.   static int \
  653.   name(Number n1, Number n2, Number r) \
  654.   { if ( !toIntegerNumber(n1) ) \
  655.       return PL_error(plop, 2, NULL, ERR_AR_TYPE, ATOM_integer, n1); \
  656.     if ( !toIntegerNumber(n2) ) \
  657.       return PL_error(plop, 2, NULL, ERR_AR_TYPE, ATOM_integer, n2); \
  658.     r->value.i = n1->value.i op n2->value.i; \
  659.     r->type = V_INTEGER; \
  660.     succeed; \
  661.   }
  662.  
  663. #define BINAIRY_FLOAT_FUNCTION(name, func) \
  664.   static int \
  665.   name(Number n1, Number n2, Number r) \
  666.   { promoteToRealNumber(n1); \
  667.     promoteToRealNumber(n2); \
  668.     r->value.f = func(n1->value.f, n2->value.f); \
  669.     r->type = V_REAL; \
  670.     succeed; \
  671.   }
  672.  
  673. UNAIRY_FLOAT_FUNCTION(ar_sin, sin)
  674. UNAIRY_FLOAT_FUNCTION(ar_cos, cos)
  675. UNAIRY_FLOAT_FUNCTION(ar_tan, tan)
  676. UNAIRY_FLOAT_FUNCTION(ar_atan, atan)
  677. UNAIRY_FLOAT_FUNCTION(ar_exp, exp)
  678.  
  679. BINAIRY_FLOAT_FUNCTION(ar_atan2, atan2)
  680. BINAIRY_FLOAT_FUNCTION(ar_pow, pow)
  681.  
  682. BINAIRY_INT_FUNCTION(ar_mod, "mod", %)
  683. BINAIRY_INT_FUNCTION(ar_disjunct, "\\/", |)
  684. BINAIRY_INT_FUNCTION(ar_conjunct, "/\\", &)
  685. BINAIRY_INT_FUNCTION(ar_shift_right, ">>", >>)
  686. BINAIRY_INT_FUNCTION(ar_shift_left, "<<", <<)
  687. BINAIRY_INT_FUNCTION(ar_xor, "xor", ^)
  688.  
  689. static int
  690. ar_sqrt(Number n1, Number r)
  691. { promoteToRealNumber(n1);
  692.   if ( n1->value.f < 0 )
  693.     return PL_error("sqrt", 1, NULL, ERR_AR_UNDEF);
  694.   r->value.f = sqrt(n1->value.f);
  695.   r->type    = V_REAL;
  696.   succeed;
  697. }
  698.  
  699.  
  700. static int
  701. ar_asin(Number n1, Number r)
  702. { promoteToRealNumber(n1);
  703.   if ( n1->value.f < -1.0 || n1->value.f > 1.0 )
  704.     return PL_error("asin", 1, NULL, ERR_AR_UNDEF);
  705.   r->value.f = asin(n1->value.f);
  706.   r->type    = V_REAL;
  707.   succeed;
  708. }
  709.  
  710.  
  711. static int
  712. ar_acos(Number n1, Number r)
  713. { promoteToRealNumber(n1);
  714.   if ( n1->value.f < -1.0 || n1->value.f > 1.0 )
  715.     return PL_error("acos", 1, NULL, ERR_AR_UNDEF);
  716.   r->value.f = acos(n1->value.f);
  717.   r->type    = V_REAL;
  718.   succeed;
  719. }
  720.  
  721.  
  722. static int
  723. ar_log(Number n1, Number r)
  724. { promoteToRealNumber(n1);
  725.   if ( n1->value.f <= 0.0 )
  726.     return PL_error("log", 1, NULL, ERR_AR_UNDEF);
  727.   r->value.f = log(n1->value.f);
  728.   r->type    = V_REAL;
  729.   succeed;
  730. }
  731.  
  732.  
  733. static int
  734. ar_log10(Number n1, Number r)
  735. { promoteToRealNumber(n1);
  736.   if ( n1->value.f <= 0.0 )
  737.     return PL_error("log10", 1, NULL, ERR_AR_UNDEF);
  738.   r->value.f = log10(n1->value.f);
  739.   r->type    = V_REAL;
  740.   succeed;
  741. }
  742.  
  743.  
  744. static int
  745. ar_div(Number n1, Number n2, Number r)
  746. { if ( !toIntegerNumber(n1) )
  747.     return PL_error("//", 2, NULL, ERR_AR_TYPE, ATOM_integer, n1);
  748.   if ( !toIntegerNumber(n2) )
  749.     return PL_error("//", 2, NULL, ERR_AR_TYPE, ATOM_integer, n2);
  750.   if ( n2->value.i == 0 )
  751.     return PL_error("//", 2, NULL, ERR_DIV_BY_ZERO);
  752.  
  753.   r->value.i = n1->value.i / n2->value.i;
  754.   r->type = V_INTEGER;
  755.  
  756.   succeed;
  757. }
  758.  
  759. static int
  760. ar_sign(Number n1, Number r)
  761. { if ( intNumber(n1) )
  762.     r->value.i = (n1->value.i <   0 ? -1 : n1->value.i >   0 ? 1 : 0);
  763.   else
  764.     r->value.i = (n1->value.f < 0.0 ? -1 : n1->value.f > 0.0 ? 1 : 0);
  765.  
  766.   r->type = V_INTEGER;
  767.   succeed;
  768. }
  769.  
  770.  
  771. static int
  772. ar_rem(Number n1, Number n2, Number r)
  773. { real f;
  774.  
  775.   if ( !toIntegerNumber(n1) )
  776.     return PL_error("rem", 2, NULL, ERR_AR_TYPE, ATOM_integer, n1);
  777.   if ( !toIntegerNumber(n2) )
  778.     return PL_error("rem", 2, NULL, ERR_AR_TYPE, ATOM_integer, n2);
  779.  
  780.   f = (real)n1->value.i / (real)n2->value.i;
  781.   r->value.f = f - (real)((long) f);
  782.   r->type = V_REAL;
  783.   succeed;
  784. }
  785.  
  786.  
  787. static int
  788. ar_divide(Number n1, Number n2, Number r)
  789. { if ( intNumber(n1) && intNumber(n2) )
  790.   { if ( n2->value.i == 0 )
  791.       return PL_error("/", 2, NULL, ERR_DIV_BY_ZERO);
  792.  
  793.     if ( n1->value.i % n2->value.i == 0)
  794.     { r->value.i = n1->value.i / n2->value.i;
  795.       r->type = V_INTEGER;
  796.       succeed;
  797.     }
  798.   }
  799.  
  800.   promoteToRealNumber(n1);
  801.   promoteToRealNumber(n2);
  802.   if ( n2->value.f == 0.0 )
  803.       return PL_error("/", 2, NULL, ERR_DIV_BY_ZERO);
  804.  
  805.   r->value.f = n1->value.f / n2->value.f;
  806.   r->type = V_REAL;
  807.   succeed;
  808. }
  809.  
  810.  
  811. static int
  812. ar_times(Number n1, Number n2, Number r)
  813. { if ( intNumber(n1) && intNumber(n2) )
  814.   { if ( abs(n1->value.i) >= (1 << 15) || abs(n2->value.i) >= (1 << 15) )
  815.     { r->value.f = (real)n1->value.i * (real)n2->value.i;
  816.       r->type = V_REAL;
  817.       succeed;
  818.     }
  819.     r->value.i = n1->value.i * n2->value.i;
  820.     r->type = V_INTEGER;
  821.     succeed;
  822.   }
  823.   
  824.   promoteToRealNumber(n1);
  825.   promoteToRealNumber(n2);
  826.  
  827.   r->value.f = n1->value.f * n2->value.f;
  828.   r->type = V_REAL;
  829.   succeed;
  830. }
  831.  
  832.  
  833. static int
  834. ar_max(Number n1, Number n2, Number r)
  835. { if ( intNumber(n1) && intNumber(n2) )
  836.   { r->value.i = (n1->value.i > n2->value.i ? n1->value.i : n2->value.i);
  837.     r->type = V_INTEGER;
  838.     succeed;
  839.   }
  840.  
  841.   promoteToRealNumber(n1);
  842.   promoteToRealNumber(n2);
  843.  
  844.   r->value.f = (n1->value.f > n2->value.f ? n1->value.f : n2->value.f);
  845.   r->type = V_REAL;
  846.   succeed;
  847. }
  848.  
  849.  
  850. static int
  851. ar_min(Number n1, Number n2, Number r)
  852. { if ( intNumber(n1) && intNumber(n2) )
  853.   { r->value.i = (n1->value.i < n2->value.i ? n1->value.i : n2->value.i);
  854.     r->type = V_INTEGER;
  855.     succeed;
  856.   }
  857.  
  858.   promoteToRealNumber(n1);
  859.   promoteToRealNumber(n2);
  860.  
  861.   r->value.f = (n1->value.f < n2->value.f ? n1->value.f : n2->value.f);
  862.   r->type = V_REAL;
  863.   succeed;
  864. }
  865.  
  866.  
  867. static int
  868. ar_negation(Number n1, Number r)
  869. { if ( !toIntegerNumber(n1) )
  870.     return PL_error("\\", 1, NULL, ERR_AR_TYPE, ATOM_integer, n1);
  871.  
  872.   r->value.i = ~n1->value.i;
  873.   r->type = V_INTEGER;
  874.   succeed;
  875. }
  876.  
  877.  
  878. static int
  879. ar_u_minus(Number n1, Number r)
  880. { if ( intNumber(n1) )
  881.   { r->value.i = -n1->value.i;
  882.     r->type = V_INTEGER;
  883.   } else
  884.   { r->value.f = -n1->value.f;
  885.     r->type = V_REAL;
  886.   }
  887.  
  888.   succeed;
  889. }
  890.  
  891.  
  892. #undef abs
  893. #define abs(a) ((a) < 0 ? -(a) : (a))
  894.  
  895. static int
  896. ar_abs(Number n1, Number r)
  897. { if ( intNumber(n1) )
  898.   { r->value.i = abs(n1->value.i);
  899.     r->type = V_INTEGER;
  900.   } else
  901.   { r->value.f = abs(n1->value.f);
  902.     r->type = V_REAL;
  903.   }
  904.  
  905.   succeed;
  906. }
  907.  
  908.  
  909. static int
  910. ar_integer(Number n1, Number r)
  911. { if ( intNumber(n1) )
  912.   { *r = *n1;
  913.     succeed;
  914.   } else
  915.   { if ( n1->value.f < PLMAXINT && n1->value.f > PLMININT )
  916.     { r->value.i = (n1->value.f > 0 ? (long)(n1->value.f + 0.5)
  917.                         : (long)(n1->value.f - 0.5));
  918.       r->type = V_INTEGER;
  919.       succeed;
  920.     }
  921. #ifdef HAVE_RINT
  922.     r->value.f = rint(n1->value.f);
  923.     r->type = V_REAL;
  924.     succeed;
  925. #else
  926.     return PL_error("integer", 1, NULL, ERR_EVALUATION, ATOM_int_overflow);
  927. #endif
  928.   }
  929. }
  930.  
  931.  
  932. static int
  933. ar_float(Number n1, Number r)
  934. { *r = *n1;
  935.   promoteToRealNumber(r);
  936.   r->type = V_EXPLICIT_REAL;        /* avoid canoniseNumber() */
  937.  
  938.   succeed;
  939. }
  940.  
  941.  
  942. static int
  943. ar_floor(Number n1, Number r)
  944. { if ( intNumber(n1) )
  945.     *r = *n1;
  946.   else
  947.   {
  948. #ifdef HAVE_FLOOR
  949.     r->value.f = floor(n1->value.f);
  950.     r->type = V_REAL;
  951. #else
  952.     r->value.i = (long)n1->value.f;
  953.     if ( n1->value.f < 0 && (real)r->value.i != n1->value.f )
  954.       r->value.i--;
  955.     r->type = V_INTEGER;
  956. #endif
  957.   }
  958.   succeed;
  959. }
  960.  
  961.  
  962. static int
  963. ar_ceil(Number n1, Number r)
  964. { if ( intNumber(n1) )
  965.     *r = *n1;
  966.   else
  967.   {
  968. #ifdef HAVE_CEIL
  969.     r->value.f = ceil(n1->value.f);
  970.     r->type = V_REAL;
  971. #else
  972.     r->value.i = (long)n1->value.f;
  973.     if ( (real)r->value.i < n1->value.f )
  974.        r->value.i++;
  975.     r->type = V_INTEGER;
  976. #endif
  977.   }
  978.  
  979.   succeed;
  980. }
  981.  
  982.  
  983. static int
  984. ar_float_fractional_part(Number n1, Number r)
  985. { if ( intNumber(n1) )
  986.   { r->value.i = 0;
  987.     r->type = V_INTEGER;
  988.   } else
  989.   { if ( n1->value.f > 0 )
  990.     { r->value.f = n1->value.f - floor(n1->value.f);
  991.     } else
  992.     { TRY(ar_ceil(n1, r));
  993.       r->value.f = n1->value.f - ceil(n1->value.f);
  994.     }
  995.     r->type = V_REAL;
  996.   }
  997.  
  998.   succeed;
  999. }
  1000.  
  1001.  
  1002. static int
  1003. ar_float_integer_part(Number n1, Number r)
  1004. { if ( intNumber(n1) )
  1005.     *r = *n1;
  1006.   else
  1007.   { if ( n1->value.f > 0 )
  1008.       return ar_floor(n1, r);
  1009.     else
  1010.       return ar_ceil(n1, r);
  1011.   }
  1012.  
  1013.   succeed;
  1014. }
  1015.  
  1016.  
  1017. static int
  1018. ar_truncate(Number n1, Number r)
  1019. { return ar_float_integer_part(n1, r);
  1020. }
  1021.  
  1022.  
  1023. static int
  1024. ar_random(Number n1, Number r)
  1025. { if ( !toIntegerNumber(n1) )
  1026.     return PL_error("random", 1, NULL, ERR_AR_TYPE, ATOM_integer, n1);
  1027.  
  1028.   r->value.i = Random() % n1->value.i;
  1029.   r->type = V_INTEGER;
  1030.  
  1031.   succeed;
  1032. }
  1033.  
  1034.  
  1035. static int
  1036. ar_pi(Number r)
  1037. { r->value.f = M_PI;
  1038.  
  1039.   r->type = V_REAL;
  1040.   succeed;
  1041. }
  1042.  
  1043.  
  1044. static int
  1045. ar_e(Number r)
  1046. { r->value.f = M_E;
  1047.  
  1048.   r->type = V_REAL;
  1049.   succeed;
  1050. }
  1051.  
  1052.  
  1053. static int
  1054. ar_cputime(Number r)
  1055. { r->value.f = CpuTime();
  1056.  
  1057.   r->type = V_REAL;
  1058.   succeed;
  1059. }
  1060.  
  1061.  
  1062.         /********************************
  1063.         *       PROLOG CONNECTION       *
  1064.         *********************************/
  1065.  
  1066. word
  1067. pl_is(term_t v, term_t e)
  1068. { number arg;
  1069.  
  1070.   if ( valueExpression(e, &arg) )
  1071.   { canoniseNumber(&arg);
  1072.     return _PL_unify_number(v, &arg);
  1073.   }
  1074.  
  1075.   fail;
  1076. }
  1077.  
  1078.  
  1079. #if O_PROLOG_FUNCTIONS
  1080. word
  1081. pl_arithmetic_function(term_t descr)
  1082. { Procedure proc;
  1083.   Definition def;
  1084.   functor_t fd;
  1085.   FunctorDef fdef;
  1086.   ArithFunction f;
  1087.   Module m = NULL;
  1088.   term_t head = PL_new_term_ref();
  1089.   int v;
  1090.  
  1091.   PL_strip_module(descr, &m, head);
  1092.   if ( !PL_get_functor(head, &fd) )
  1093.     return warning("arithmetic_function/1: Illegal head");
  1094.   fdef = valueFunctor(fd);
  1095.   if ( fdef->arity < 1 )
  1096.     return warning("arithmetic_function/1: Illegal arity");
  1097.  
  1098.   proc = lookupProcedure(fd, m);
  1099.   def = proc->definition;
  1100.   fd = lookupFunctorDef(fdef->name, fdef->arity - 1);
  1101.   if ( (f = isCurrentArithFunction(fd, m)) && f->module == m )
  1102.     succeed;                /* already registered */
  1103.  
  1104.   v = functorHashValue(fd, ARITHHASHSIZE);
  1105.   f = allocHeap(sizeof(struct arithFunction));
  1106.   f->functor  = fd;
  1107.   f->function = NULL;
  1108.   f->module   = m;
  1109.   f->proc     = proc;
  1110.  
  1111.   startCritical;
  1112.   f->next     = arithFunctionTable[v];
  1113.   arithFunctionTable[v] = f;  
  1114.   registerFunction(f);
  1115.   endCritical;
  1116.  
  1117.   succeed;
  1118. }
  1119.  
  1120. word
  1121. pl_current_arithmetic_function(term_t f, word h)
  1122. { ArithFunction a;
  1123.   Module m = NULL;
  1124.   term_t head = PL_new_term_ref();
  1125.  
  1126.   switch( ForeignControl(h) )
  1127.   { case FRG_FIRST_CALL:
  1128.     { functor_t fd;
  1129.  
  1130.       PL_strip_module(f, &m, head);
  1131.  
  1132.       if ( PL_is_variable(head) )
  1133.       { a = arithFunctionTable[0];
  1134.         break;
  1135.       } else if ( PL_get_functor(head, &fd) )
  1136.       {    return isCurrentArithFunction(fd, m) ? TRUE : FALSE;
  1137.       } else
  1138.         return warning("current_arithmetic_function/2: instantiation fault");
  1139.     }
  1140.     case FRG_REDO:
  1141.       PL_strip_module(f, &m, head);
  1142.  
  1143.       a = ForeignContextPtr(h);
  1144.       break;
  1145.     case FRG_CUTTED:
  1146.     default:
  1147.       succeed;
  1148.   }
  1149.  
  1150.   for( ; a; a = a->next )
  1151.   { Module m2;
  1152.  
  1153.     while( isTableRef(a) )
  1154.     { a = unTableRef(ArithFunction, a);
  1155.       if ( !a )
  1156.         fail;
  1157.     }
  1158.  
  1159.     for(m2 = m; m2; m2 = m2->super)
  1160.     { if ( m2 == a->module && a == isCurrentArithFunction(a->functor, m) )
  1161.       { if ( PL_unify_functor(f, a->functor) )
  1162.       return_next_table(ArithFunction, a, ;);
  1163.       }
  1164.     }
  1165.   }
  1166.  
  1167.   fail;
  1168. }
  1169.  
  1170. #endif /* O_PROLOG_FUNCTIONS */
  1171.  
  1172. typedef struct
  1173. { functor_t    functor;
  1174.   ArithF    function;
  1175. } ar_funcdef;
  1176.  
  1177. #define ADD(functor, func) { functor, func }
  1178.  
  1179. static const ar_funcdef ar_funcdefs[] = {
  1180.   ADD(FUNCTOR_plus2,        ar_add),
  1181.   ADD(FUNCTOR_minus2,        ar_minus),
  1182.   ADD(FUNCTOR_star2,        ar_times),
  1183.   ADD(FUNCTOR_divide2,        ar_divide),
  1184.   ADD(FUNCTOR_minus1,        ar_u_minus),
  1185.   ADD(FUNCTOR_abs1,        ar_abs),
  1186.   ADD(FUNCTOR_max2,        ar_max),
  1187.   ADD(FUNCTOR_min2,        ar_min),
  1188.  
  1189.   ADD(FUNCTOR_mod2,        ar_mod),
  1190.   ADD(FUNCTOR_rem2,        ar_rem),
  1191.   ADD(FUNCTOR_div2,        ar_div),
  1192.   ADD(FUNCTOR_sign1,        ar_sign),
  1193.  
  1194.   ADD(FUNCTOR_and2,        ar_conjunct),
  1195.   ADD(FUNCTOR_or2,        ar_disjunct),
  1196.   ADD(FUNCTOR_rshift2,        ar_shift_right),
  1197.   ADD(FUNCTOR_lshift2,        ar_shift_left),
  1198.   ADD(FUNCTOR_xor2,        ar_xor),
  1199.   ADD(FUNCTOR_backslash1,    ar_negation),
  1200.  
  1201.   ADD(FUNCTOR_random1,        ar_random),
  1202.  
  1203.   ADD(FUNCTOR_integer1,        ar_integer),
  1204.   ADD(FUNCTOR_round1,        ar_integer),
  1205.   ADD(FUNCTOR_truncate1,    ar_truncate),
  1206.   ADD(FUNCTOR_float1,        ar_float),
  1207.   ADD(FUNCTOR_floor1,        ar_floor),
  1208.   ADD(FUNCTOR_ceil1,        ar_ceil),
  1209.   ADD(FUNCTOR_ceiling1,        ar_ceil),
  1210.   ADD(FUNCTOR_float_fractional_part1, ar_float_fractional_part),
  1211.   ADD(FUNCTOR_float_integer_part1, ar_float_integer_part),
  1212.  
  1213.   ADD(FUNCTOR_sqrt1,        ar_sqrt),
  1214.   ADD(FUNCTOR_sin1,        ar_sin),
  1215.   ADD(FUNCTOR_cos1,        ar_cos),
  1216.   ADD(FUNCTOR_tan1,        ar_tan),
  1217.   ADD(FUNCTOR_asin1,        ar_asin),
  1218.   ADD(FUNCTOR_acos1,        ar_acos),
  1219.   ADD(FUNCTOR_atan1,        ar_atan),
  1220.   ADD(FUNCTOR_atan2,        ar_atan2),
  1221.   ADD(FUNCTOR_log1,        ar_log),
  1222.   ADD(FUNCTOR_exp1,        ar_exp),
  1223.   ADD(FUNCTOR_log101,        ar_log10),
  1224.   ADD(FUNCTOR_hat2,        ar_pow),
  1225.   ADD(FUNCTOR_doublestar2,    ar_pow),
  1226.   ADD(FUNCTOR_pi0,        ar_pi),
  1227.   ADD(FUNCTOR_e0,        ar_e),
  1228.  
  1229.   ADD(FUNCTOR_cputime0,        ar_cputime),
  1230. };
  1231.  
  1232. #undef ADD
  1233.  
  1234. static void
  1235. registerFunction(ArithFunction f)
  1236. { f->index = entriesBuffer(function_array, ArithFunction);
  1237.   addBuffer(function_array, f, ArithFunction);
  1238. }
  1239.  
  1240.  
  1241. static void
  1242. registerBuiltinFunctions()
  1243. { int n, size = sizeof(ar_funcdefs)/sizeof(ar_funcdef);
  1244.   ArithFunction f = allocHeap(size * sizeof(struct arithFunction));
  1245.   const ar_funcdef *d;
  1246.  
  1247.                     /* grow to desired size immediately */
  1248.   growBuffer(function_array, size * sizeof(ArithFunction));
  1249.   memset(f, 0, size * sizeof(struct arithFunction));
  1250.  
  1251.   for(d = ar_funcdefs, n=0; n<size; n++, f++, d++)
  1252.   { int v = functorHashValue(d->functor, ARITHHASHSIZE);
  1253.  
  1254.     f->functor  = d->functor;
  1255.     f->function = d->function;
  1256.     f->module   = MODULE_system;
  1257.     f->next     = arithFunctionTable[v];
  1258.     arithFunctionTable[v] = f;
  1259.     registerFunction(f);
  1260.     DEBUG(1, Sdprintf("Registered %s/%d at %d, index=%d\n",
  1261.               stringAtom(nameFunctor(f->functor)),
  1262.               arityFunctor(f->functor),
  1263.               v,
  1264.               f->index));
  1265.   }                   
  1266. }
  1267.  
  1268.  
  1269. void
  1270. initArith(void)
  1271. { 
  1272. #ifdef SIGFPE
  1273.   pl_signal(SIGFPE, (handler_t) realExceptionHandler);
  1274. #endif
  1275. #if __TURBOC__
  1276.   setmatherr(realExceptionHandler);
  1277. #endif
  1278.  
  1279.   initBuffer(function_array);
  1280.                     /* link the table to enumerate */
  1281.   { ArithFunction *f;
  1282.     int n;
  1283.  
  1284.     for(n=0, f = arithFunctionTable; n < (ARITHHASHSIZE-1); n++, f++)
  1285.       *f = makeTableRef(f+1);
  1286.   }
  1287.  
  1288.   registerBuiltinFunctions();
  1289. }
  1290.  
  1291. #if O_COMPILE_ARITH
  1292.  
  1293.         /********************************
  1294.         *    VIRTUAL MACHINE SUPPORT    *
  1295.         *********************************/
  1296.  
  1297. int
  1298. indexArithFunction(functor_t fdef, register Module m)
  1299. { ArithFunction f;
  1300.  
  1301.   if ( !(f = isCurrentArithFunction(fdef, m)) )
  1302.     return -1;
  1303.  
  1304.   return (int)f->index;
  1305. }
  1306.  
  1307.  
  1308. functor_t
  1309. functorArithFunction(int n)
  1310. { return FunctionFromIndex(n)->functor;
  1311. }
  1312.  
  1313.  
  1314. bool
  1315. ar_func_n(code n, int argc, Number *stack)
  1316. { number result;
  1317.   int rval;
  1318.   ArithFunction f = FunctionFromIndex((int)n);
  1319.   Number sp = *stack;
  1320.  
  1321.   sp -= argc;
  1322.   if ( f->proc )
  1323.   { LocalFrame lSave = lTop;        /* TBD (check with stack!) */
  1324.     term_t h0;
  1325.     int n;
  1326.  
  1327.     lTop = (LocalFrame) (*stack);
  1328.     h0   = PL_new_term_refs(argc+1);
  1329.     
  1330.     for(n=0; n<argc; n++)
  1331.       _PL_put_number(h0+n, &sp[n]);
  1332.  
  1333.     rval = prologFunction(f, h0, &result);
  1334.     lTop = lSave;
  1335.   } else
  1336.   { switch(argc)
  1337.     { case 0:
  1338.     rval = (*f->function)(&result);
  1339.         break;
  1340.       case 1:
  1341.     rval = (*f->function)(sp, &result);
  1342.         break;
  1343.       case 2:
  1344.     rval = (*f->function)(sp, &sp[1], &result);
  1345.         break;
  1346.       default:
  1347.     rval = FALSE;
  1348.         sysError("Too many arguments to arithmetic function");
  1349.     }
  1350.   }
  1351.  
  1352.   if ( rval )
  1353.   { if ( result.type == V_REAL )
  1354.     {
  1355. #ifdef HUGE_VAL
  1356.       if ( result.value.f == HUGE_VAL )
  1357.     return PL_error(NULL, 0, NULL, ERR_AR_OVERFLOW);
  1358. #endif
  1359. #ifdef HAVE_ISNAN
  1360.       if ( isnan(result.value.f) )
  1361.     return PL_error(NULL, 0, NULL, ERR_AR_UNDEF);
  1362. #endif
  1363.     }
  1364.  
  1365.     *sp++ = result;
  1366.     *stack = sp;
  1367.   }
  1368.  
  1369.   return rval;
  1370. }
  1371.  
  1372. #endif /* O_COMPILE_ARITH */
  1373.